;;;-*-LISP-*-
;;; Simplest possible rubout handler, featureful yet grubby.
;;; Adapted for use under maclisp in the 6.001 Scheme System,
;;; from the NIL's bootstrap rubout handler, which
;;; was in turn adapted from GJC's hack for maclisp CGOL.
;;; 5:31am  Thursday, 13 August 1981 -George Carrette.
;;; Supports: Catching of readtime errors!
;;;           Rubout ... rub out last character and last read error.
;;;           ↑W ....... rub out last word.
;;;           ↑K ....... clear input.
;;;           ↑R ....... redisplay without clear screen
;;;           ↑L ....... clear screen and redisplay.
;;;           ↑E ....... the calling of an external editor.
;;;           ↑Y ....... yank the LAST thing read in.
;;; Note    : Does not require turning off of system tty-echoing.
;;;           This is featureful for TOPS-20.

;;; Exported functions:
;;; TTY-READ      &optional "prompt"
;;; TTY-READLINE  &optional "prompt"
;;; TTY-TYI       &optional "prompt"
;;; TTY-REDISPLAY &optional "message"
;;; TTY-PRINTLINE &optional "line1" "line2" "line3" ...

(herald "Gjc-reader")

(DECLARE (*LEXPR TOPLEVEL-EDITOR-CALL ; externally defined
		 TTY-PRINTLINE        ; forward ref.
		 )
	 (special bad-tty? echofiles-value status-ttysize))

(EVAL-WHEN (EVAL COMPILE)
  (or (fboundp 'defstruct)
      (load (caseq (status opsys)
	      ((tops-20)
	       (OR (PROBEF '((LISP)STRUCT FASL))
		   "<GJC.LISP>STRUCT"))
	      ((ITS) "LIBLSP;STRUCT")
	      (T '((LISP)STRUCT))))))

(defmacro errset-bind (handler &rest body)
  `(let ((errset ,handler)
	 (undf-fnctn    nil)
	 (unbnd-vrbl    nil)
	 (wrng-type-arg nil)
	 (unseen-go-tag nil)
	 (wrng-no-args  nil)
	 (fail-act      nil)
	 (*rset-trap    nil)
	 (pdl-overflow  nil)
	 (io-lossage    nil))
	(car (errset (progn ,@body) nil))))

(defstruct (grubout-tty sfa conc-name default-pointer)
  (tyi tyi)
  (tyo tyo)
  (prompt #'grub-prompt)
  grubout untyi display to-yank kill-buffer)

(DEFVAR READ-PROMPT "> ")

(defun grub-prompt (stream) (princ read-prompt stream))

;; the display is a list ((c . (v-pos . h-pos)) (c . (v-pos . h-pos)) ...)
;; where the cursorpos is that before the character was echoed.
;; we should also be keeping the position of the cursor after echoing,
;; but we don't because it only rarely causes glitches, which can be
;; removed by typing ↑L.

(defvar scrolling? (EQ 'TOPS-20 (STATUS OPSYS)))
(defvar status-ttysize (status ttysize))

(defun grubout-tty-tyi-and-display (grubout-tty)
  (let ((pos (cursorpos (grubout-tty-tyo))))
    (let ((c  (if (grubout-tty-to-yank)
		  (let ((c (pop (grubout-tty-to-yank))))
		    (tyo c (grubout-tty-tyo))
		    c)
		  (tyi (grubout-tty-tyi)))))
      (push (cons c pos) (grubout-tty-display))
      (cond ((and scrolling? (= c #\LF)
		  (=  (car pos) (1- (car status-ttysize))))
	     (do ((l (grubout-tty-display) (cdr l)))
		 ((null l))
	       (rplaca (cdar l) (1- (cadar l))))))
      c)))

(defun re-display (grubout-tty)
  (cursorpos 'a (grubout-tty-tyo))
  (funcall (grubout-tty-prompt) (grubout-tty-tyo))
  (re-display-sub (grubout-tty-display) (grubout-tty-tyo)
		  (cursorpos (grubout-tty-tyo))))

(defun re-display-sub (l s c)
  (cond ((null l))
	(t
	 (re-display-sub (cdr l) s c)
	 (setf (cdr (car l)) (cursorpos s))
	 (tyo (caar l) s))))

(defun grub-out-display (grubout-tty)
  (if (grubout-tty-display)
      (let (((char . cp-before) (pop (grubout-tty-display))))
	(cond ((or (null cp-before)
		   ;; patch for tops-20 maclisp lossage.
		   bad-tty?)
	       ;; no cursorpos information, probably a printing terminal,
	       ;; so call the primitive rubout function.
	       (rubout char (grubout-tty-tyo)))
	      ('else
	       ;; kill all lines between where we are and where we want
	       ;; to be. this covers the important case of an error message
	       ;; which was printed on the screen before we decided to
	       ;; rubout, or any unsolicited output, say from ddt.
	       (do ((first t))(nil)
		 (let ((cp (cursorpos (grubout-tty-tyo))))
		   (if (= (car cp) (car cp-before)) (return nil))
		   (cond (first
			  (setq first nil)
			  (cond ((not (= (cdr cp) 0))
				 (cursorpos 'h 0 (grubout-tty-tyo))
				 (cursorpos 'l (grubout-tty-tyo)))))
			 ('else
			  (cursorpos 'l (grubout-tty-tyo))
			  (cursorpos 'u (grubout-tty-tyo))))))
	       ;; set the cursorpos back to what it was before.
	       (cursorpos (car cp-before) (cdr cp-before) (grubout-tty-tyo))
	       ;; now kill the rest of that line.
	       (or (= char #\cr) (cursorpos 'l (grubout-tty-tyo)))))
	(setf (grubout-tty-grubout) 'true))))

(defvar grubout-tty-ops ())

(defmacro define-grubout-tty-op (name l &rest body)
  `(progn 'compile
	  (defun (,name grubout-tty-op) ,l ,@body)
	  (or (memq ',name grubout-tty-ops)
	      (push ',name grubout-tty-ops))))

(defun grubout-tty (grubout-tty com arg)
  (funcall (or (get com 'grubout-tty-op)
	       (error "BUG: Undefined grubout-tty operation." COM 'FAIL-ACT))
	   grubout-tty
	   arg))

(define-grubout-tty-op which-operations (ignore1 ignore2)
  grubout-tty-ops)

(define-grubout-tty-op tyi (grubout-tty ignore)
  (if (grubout-tty-untyi)
      (pop (grubout-tty-untyi))
      (do ((c))(nil)
	(setq c (grubout-tty-tyi-and-display grubout-tty))
	(if (funcall (get-grubout-tty-command c) c grubout-tty)
	    (return c)))))

(define-grubout-tty-op untyi (grubout-tty arg)
  (push arg (grubout-tty-untyi)))

(define-grubout-tty-op tyipeek (grubout-tty arg)
  (let ((c (tyi grubout-tty arg)))
    (sfa-call grubout-tty 'untyi c)
    c))

(define-grubout-tty-op init (grubout-tty ignore)
  (setf (grubout-tty-grubout) ())
  (setf (grubout-tty-to-yank) ())
  (setf (grubout-tty-kill-buffer)
	(nreverse (cdr (mapcar #'car (grubout-tty-display)))))
  (setf (grubout-tty-display)
	(nreverse (mapcar #'list (grubout-tty-untyi))))
  (re-display grubout-tty))

(define-grubout-tty-op after-read (grubout-tty reader)
  (if (eq reader 'read)
      (flush-untyi-whitespace grubout-tty))
  (cond (echofiles-value
	 (terpri echofiles-value)
	 (funcall (grubout-tty-prompt) echofiles-value)
	 (echofiles-value-revout (grubout-tty-display)))))

(defun echofiles-value-revout (l)
  (if l
      (progn (echofiles-value-revout (cdr l))
	     (tyo (caar l) echofiles-value))))

(defun flush-untyi-whitespace (grubout-tty)
  (do ((l (grubout-tty-untyi) (cdr l)))
      ((or (null l)
	   (not (whitespacep/.code-char (car l))))
       (setf (grubout-tty-untyi) l))))

(defvar grubout-tty-plist (list 'grubout-tty-plist))

(defun get-grubout-tty-command (c)
  (or (do ((l (cdr grubout-tty-plist) (cdr l)))
	  ((null l))
	(and (= (car l) c) (return (cadr l))))
      #'grubout-tty-default))

(defun grubout-tty-default (ignore-c grubout-tty)
  (cond ((and (grubout-tty-grubout) (grubout-tty-display))
	 (setf (grubout-tty-grubout) ())
	 (setf (grubout-tty-untyi)
	       (nreverse (mapcar #'car (grubout-tty-display))))
	 (*throw 'grubout nil))
	('else 'true)))

(defmacro define-grubout-command (c argl &rest body)
  (let ((name (implode (nconc (exploden "GRUBOUT-COMMAND-") (exploden c)))))
    `(progn 'compile
	    (defun ,name ,argl ,@body)
	    (putprop grubout-tty-plist #',name ,c))))

(defun pop-grubout-tty-display (grubout-tty)
  ;; called inside naturally non-echoing characters.
  (pop (grubout-tty-display)))

(define-grubout-command #\FF (ignore-c grubout-tty)
  (pop-grubout-tty-display grubout-tty)
  (if bad-tty?
      (terpri (grubout-tty-tyo))
      (cursorpos 'c (grubout-tty-tyo)))
  (re-display grubout-tty)
  ())

(define-grubout-command #↑R (ignore-c grubout-tty)
  (pop-grubout-tty-display grubout-tty)
  (re-display grubout-tty)
  ())

(define-grubout-command #\RUBOUT (ignore-c grubout-tty)
  (pop-grubout-tty-display grubout-tty)
  (grub-out-display grubout-tty)
  ())

(define-grubout-command #↑K (ignore-c grubout-tty)
  (grub-out-display grubout-tty)
  (do ()
      ((not (grubout-tty-display)))
    (grub-out-display grubout-tty))
   ())

(define-grubout-command #↑W (ignore-c grubout-tty)
  (grub-out-display grubout-tty)
  (do ()
      ((not (grubout-tty-display)))
    (if (whitespacep/.code-char (caar (grubout-tty-display)))
	(grub-out-display grubout-tty)
	(return ())))
  (do ()
      ((not (grubout-tty-display)))
    (if (whitespacep/.code-char (caar (grubout-tty-display)))
	(return ())
	(grub-out-display grubout-tty)))
   ())

(define-grubout-command #↑Y (ignore-c grubout-tty)
  (grub-out-display grubout-tty)
  (setf (grubout-tty-to-yank) (grubout-tty-kill-buffer))
  ())

(defstruct (grubout-handler sfa conc-name default-pointer)
  (substream (make-grubout-tty)))

(defun create-grubout-handler () (make-grubout-handler))

(defvar grubout-handler-substream () "NIL at toplevel")

(defvar scrolling-jump 4)
(defun handle-error-during-read ignore
  (setf (grubout-tty-to-yank grubout-handler-substream) ())
  (let ((to (grubout-tty-tyo grubout-handler-substream)))
    (let* ((p (cursorpos to))
	   (h (- (car status-ttysize) (car p) 1)))
      (cond ((and scrolling? (< h scrolling-jump))
	     (do ((j 0 (1+ j)))
		 ((= j scrolling-jump))
	       (tyo #\LF to))
	     (do ((l (grubout-tty-display grubout-handler-substream) (cdr l))
		  (s (- scrolling-jump h)))
		 ((null l)
		  (cursorpos (- (car p) s) (cdr p) to))
	       (rplaca (cdar l) (- (cadar l) s))))))
    (errprint () to)
    (cursorpos 'a to)
    (do () (()) (tyi grubout-handler-substream))))


(defun grubout-handler (grubout-handler com arg)
  (caseq com
    ((RUBOUT-HANDLER)
     (let ((grubout-handler-substream (grubout-handler-substream))
	   (bad-tty? (and (eq 'tops-20 (status opsys))
			  (< (status ttytyp) 9.)))
	   (status-ttysize (status ttysize))
	   (echofiles ())
	   (echofiles-value echofiles))
       (PROG2 (sfa-call grubout-handler-substream 'init ())
	      (do ()(nil)
		(*catch 'grubout
		  (errset-bind #'handle-error-during-read
			       (return (funcall (car arg)
						grubout-handler-substream
						(caddr arg))))))
	      (SFA-CALL GRUBOUT-HANDLER-SUBSTREAM 'AFTER-READ (CAR ARG)))))
    ((which-operations)
     '(RUBOUT-HANDLER  TYI UNTYI TYIPEEK))
    ;; random other calls have to go to the substream of the substream.
    (TYI
     (TYI (GRUBOUT-TTY-TYI (GRUBOUT-HANDLER-SUBSTREAM)) ARG))
    (UNTYI
     (UNTYI ARG (GRUBOUT-TTY-TYI (GRUBOUT-HANDLER-SUBSTREAM))))
    (TYIPEEK
     (TYIPEEK () (GRUBOUT-TTY-TYI (GRUBOUT-HANDLER-SUBSTREAM))))))

(DECLARE (SPECIAL GRUBOUT-handler))

(setq grubout-handler (create-grubout-handler))

(defun whitespacep/.code-char (x)
  (member x '(#\sp #\tab #\cr #\lf #\ff)))

(sstatus ttyint #↑w ())

(defun grubout-handler-call (f)
  (let ((stream grubout-handler)
	(grubout-handler ()))
    ;; just in case there are calls to the rubout handler
    ;; while we are reading something else.
    (or stream (setq stream (create-grubout-handler)))
    (sfa-call stream 'rubout-handler (list f stream))))

(defun tty-read (&optional (read-prompt ""))
  (grubout-handler-call 'read))

(defun tty-readline (&optional (read-prompt ""))
  (grubout-handler-call 'readline))

(defun tty-tyi (&optional (read-prompt ""))
  (grubout-handler-call 'tyi))

(defun tty-redisplay (&optional (message ""))
  (cond (grubout-handler-substream
	 (cursorpos 'a (grubout-tty-tyo grubout-handler-substream))
	 (princ message (grubout-tty-tyo grubout-handler-substream))
	 (re-display grubout-handler-substream))
	('else
	 (tty-printline message))))

(defun tty-printline (&rest l)
  (do ()
      ((NULL L))
    (cursorpos 'a tyo)
    (princ (pop l) tyo)
    (terpri tyo)))